home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / mng-test.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  3.1 KB  |  101 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         mng-test.lsp
  5. ; RCS:          $Header: mng-test.lsp,v 1.3 91/10/05 18:31:51 mayer Exp $
  6. ; Description:  Fooling around with managing and unmanaging widget arrays/lists
  7. ; Author:       Niels Mayer, HPLabs
  8. ; Created:      Sat Nov 25 01:15:31 1989
  9. ; Modified:     Sat Oct  5 18:31:31 1991 (Niels Mayer) mayer@hplnpm
  10. ; Language:     Lisp
  11. ; Package:      N/A
  12. ; Status:       X11r5 contrib tape release
  13. ;
  14. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. ;
  17. ; Permission to use, copy, modify, distribute, and sell this software and its
  18. ; documentation for any purpose is hereby granted without fee, provided that
  19. ; the above copyright notice appear in all copies and that both that
  20. ; copyright notice and this permission notice appear in supporting
  21. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  24. ; makes no representations about the suitability of this software for any
  25. ; purpose.  It is provided "as is" without express or implied warranty.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28.  
  29. (setq buts                ;this gets set to an array of 100 pushbuttons
  30.       (do* 
  31.        (;; local vars
  32.     (top_w (send TOP_LEVEL_SHELL_WIDGET_CLASS :new
  33.              :XMN_GEOMETRY "500x500+0+0"
  34.              ))
  35.     (rc_w (send XM_ROW_COLUMN_WIDGET_CLASS :new :unmanaged top_w
  36.             :XMN_ADJUST_LAST nil
  37.             ))
  38.     (i 0 (1+ i))
  39.     (num-buttons 100)
  40.     (buttons (make-array num-buttons))
  41.     )
  42.        (;; test and return
  43.     (= i num-buttons)
  44.     (xt_manage_children buttons)
  45.     (send rc_w :manage)
  46.     (send top_w :realize)
  47.     buttons                ;return array of buttons
  48.     )
  49.        ;; body
  50.        (setf (aref buttons i) 
  51.          (send XM_PUSH_BUTTON_GADGET_CLASS :new :managed "name" rc_w
  52.            :XMN_LABEL_STRING (format nil "Button ~A" i)
  53.            ))
  54.        (send (aref buttons i) :add_callback :XMN_ACTIVATE_CALLBACK
  55.          '()
  56.          `((format T "Hit Button ~A\n" ,i)
  57.            ))
  58.  
  59.        (setq *rowcol_w* rc_w)
  60.        ))
  61.  
  62. (setq rc-children (send *rowcol_w* :get_children))
  63. (setq num-children (length rc-children))
  64. (progn buts)
  65.  
  66. (do ((i 0 (1+ i)))
  67.     ((= i num-children) ":get_children ok...")
  68.     (if (not (eq (aref buts i) (aref rc-children i)))
  69.     (error "foo"))
  70.     )
  71.  
  72.  
  73. (setq buts2 (make-array 50))
  74. (copy-array buts buts2)
  75. (length buts)
  76. (length buts2)
  77.  
  78. (xt_unmanage_children buts2)
  79. (xt_manage_children buts2)
  80.  
  81. (xt_unmanage_children buts)
  82. (xt_manage_children buts)
  83.  
  84. (xt_unmanage_children (send *rowcol_w* :get_children))
  85. (xt_manage_children (send *rowcol_w* :get_children))
  86.  
  87. (setq butlist nil)
  88. (dotimes (i 10)
  89.      (setq butlist 
  90.            (cons (send XM_PUSH_BUTTON_GADGET_CLASS :new :unmanaged "name" *rowcol_w*
  91.                :XMN_LABEL_STRING (format nil "Button ~A" (gensym))
  92.                )
  93.              butlist))
  94.      )
  95.  
  96. (xt_manage_children butlist)
  97. (xt_unmanage_children butlist)
  98.  
  99. (xt_manage_children (cdr butlist))
  100. (xt_unmanage_children (cdr butlist))
  101.